;; This program is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
 ;; the Free Software Foundation, either version 3 of the License, or
 ;; (at your option) any later version.
 
 ;; This program is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 
 ;; Library of functions for Gambit-C for sending events to Windows applications in order to script their use.
 ;; Andrew Whaley (andrew@trailgauge.com)
 
 ;; Copyright 2009 Andrew Whaley

(c-declare "
#include <mshtml.h>
")

;; Used for named parameters - can't use DSSSL because I need define-syntax (roll-on R6RS support for Gambit)
(define position: 1)
(define alt: 2)
(define name: 3)
(define id: 4)
(define item: 5)
(define text: 6)

;; Parameter to hold the current window HWND reference
(define current-window (make-parameter 0)) 

;; Wrappers for low level C functions - refer to documentation further down for Scheme functions.
(define _find-window (c-lambda (nonnull-wchar_t-string) int "___result = find_window(___arg1);"))
(define _new-window (c-lambda (nonnull-char-string) int "___result = new_window(___arg1);"))
(define com-create-object (c-lambda (nonnull-wchar_t-string) int "___result = com_create_object(___arg1);"))
(define com-set-property (c-lambda (int nonnull-wchar_t-string int) void "com_set_property(___arg1, ___arg2, ___arg3);"))
(define com-invoke (c-lambda (int nonnull-wchar_t-string nonnull-wchar_t-string) void "com_invoke(___arg1, ___arg2, ___arg3);"))
(define create-browser (c-lambda (nonnull-wchar_t-string) int "___result = browser_create(___arg1);"))
(define _click-link (c-lambda (int int nonnull-wchar_t-string) int "___result = browser_click_link(___arg1, ___arg2, ___arg3);"))
(define _click-image (c-lambda (int int nonnull-wchar_t-string nonnull-wchar_t-string) int "___result = browser_click_image(___arg1, ___arg2, ___arg3, ___arg4);"))
(define _navigate-to (c-lambda (int nonnull-wchar_t-string) void "browser_navigate_to(___arg1, ___arg2);"))
(define _click-button (c-lambda (int nonnull-wchar_t-string) void "browser_click_button(___arg1, ___arg2);"))
(define _set-checkbox (c-lambda (int bool int nonnull-wchar_t-string) void "browser_set_checkbox(___arg1, ___arg2, ___arg3, ___arg4);"))
(define _get-checkbox (c-lambda (int int nonnull-wchar_t-string) bool "___result = browser_get_checkbox(___arg1, ___arg2, ___arg3);"))
(define _set-radio (c-lambda (int bool int) void "browser_set_radio(___arg1, ___arg2, ___arg3);"))
(define _get-radio (c-lambda (int int) bool "___result = browser_get_radio(___arg1, ___arg2);"))
(define _enter-text (c-lambda (int nonnull-wchar_t-string int nonnull-wchar_t-string) void "browser_enter_text(___arg1, ___arg2, ___arg3, ___arg4);"))
(define _select-item (c-lambda (int int nonnull-wchar_t-string int nonnull-wchar_t-string) void "browser_select_item(___arg1, ___arg2, ___arg3, ___arg4, ___arg5);"))
(define _window-close (c-lambda (int) void "browser_window_close(___arg1);"))
(define _get-entered-text (c-lambda (int int nonnull-wchar_t-string) scheme-object "
  ___SCMOBJ response;
  char * buffer = (char *) malloc(32768); 
  browser_get_entered_text(___arg1, ___arg2, ___arg3, buffer);         
  ___UTF_8STRING_to_SCMOBJ(buffer,&response,0);
  ___release_scmobj(response);        
  ___result = response;
  free(buffer);
"))
(define _get-selected-item (c-lambda (int int nonnull-wchar_t-string) scheme-object "
  ___SCMOBJ response;
  char * buffer = (char *) malloc(32768); 
  browser_get_selected_item(___arg1, ___arg2, ___arg3, buffer);         
  ___UTF_8STRING_to_SCMOBJ(buffer,&response,0);
  ___release_scmobj(response);        
  ___result = response;
  free(buffer);
"))
(define _get-html (c-lambda (int) scheme-object "
  ___SCMOBJ response;
  char * buffer = (char *) malloc(512 * 1024); 
  browser_get_html(___arg1, buffer);         
  ___UTF_8STRING_to_SCMOBJ(buffer,&response,0);
  ___release_scmobj(response);        
  ___result = response;
  free(buffer);
"))
(define _get-text (c-lambda (int) scheme-object "
  ___SCMOBJ response;
  char * buffer = (char *) malloc(512 * 1024); 
  browser_get_text(___arg1, buffer);         
  ___UTF_8STRING_to_SCMOBJ(buffer,&response,0);
  ___release_scmobj(response);        
  ___result = response;
  free(buffer);
"))
(define _get-tabulated-text (c-lambda (int) scheme-object "
  ___SCMOBJ response;
  char * buffer = (char *) malloc(512 * 1024); 
  browser_get_tabulated_text(___arg1, buffer);         
  ___UTF_8STRING_to_SCMOBJ(buffer,&response,0);
  ___release_scmobj(response);        
  ___result = response;
  free(buffer);
"))
(define _get-tabulated-table-text (c-lambda (int nonnull-wchar_t-string) scheme-object "
  ___SCMOBJ response;
  char * buffer = (char *) malloc(512 * 1024); 
  browser_get_tabulated_table_text(___arg1, ___arg2, buffer);         
  ___UTF_8STRING_to_SCMOBJ(buffer,&response,0);
  ___release_scmobj(response);        
  ___result = response;
  free(buffer);
"))
;; Set current window to existing named Window e.g.
;; (with-window "Logon - Microsoft Internet Explorer"  
;;    (click-button "Logon") ) 
;; 
(define-syntax with-window 
  (syntax-rules () 
    ((_ name expression ...) 
     (let ((old-window (current-window))) 
       (dynamic-wind 
         (lambda () (current-window (find-window name))) 
         (lambda () expression ...) 
         (lambda () (current-window old-window)
                    )))))) 

;; Set current window to a new Window e.g.
;; (with-new-window "calc.exe"  
;;    (click-button "=") ) 
;; 
(define-syntax with-new-window 
  (syntax-rules () 
    ((_ name expression ...) 
     (let ((old-window (current-window))) 
       (dynamic-wind 
         (lambda () (current-window (_new-window name))) 
         (lambda () expression ...) 
         (lambda () (current-window old-window)
                    )))))) 

;; Set current window to a new Internet Explorer window with URL e.g.
;; (with-new-browser "http://www.google.co.uk"  
;;    (click-button "Search") ) 
;; 
(define-syntax with-new-browser 
  (syntax-rules () 
    ((_ url expression ...) 
     (let ((old-window (current-window))) 
       (dynamic-wind 
         (lambda () (current-window (create-browser url))) 
         (lambda () expression ...) 
         (lambda () (current-window old-window)
                    )))))) 

;; Click an anchor link on the page with the text
;; (only works with browser windows !)
(define (click-link type val)
  (let ((position 0) (text #f))
    (cond
      ((eq? type position:) (set! position val))
      ((eq? type text:) (set! text val))
      (else (raise "Unknown parameter to click-link - need either position: or text:")))
  
    (if (not (eq? text #f))
       (if (= (_click-link (current-window) -1 text) -1) (raise (string-append "Link not found, text: " val)))
       (if (= (_click-link (current-window) position "") -1) (raise (string-append "Link not found, position: " val)))        
        ))    
  )

;; Click an image on the page, found by either position, alt text or id.
;; The image can either be an <IMG> tag or an <INPUT type="image">
;; (only works with browser windows !)
(define (click-image type val)
  (let ((position 0) (id #f) (alt #f))
    (cond
      ((eq? type position:) (set! position val))
      ((eq? type alt:) (set! alt val))
      ((eq? type id:) (set! id val))
      (else (raise "Unknown parameter to click-image - need either position:, id: or alt:")))
    
    (cond
     ((not (eq? id #f)) (if (= (_click-image (current-window) 0 "" id) -1) (raise (string-append "Image not found for id: " id))))
     ((not (eq? alt #f)) (if (= (_click-image (current-window) 0 alt "") -1) (raise (string-append "Image not found for alt: " alt))))
     (else (if (= (_click-image (current-window) position "" "") -1) (raise (string-append "Image not found for position: " position))))))
  )

;; Navigate the browser to a new URL
;; (only works with browser windows !)
(define (navigate-to url)
    (_navigate-to (current-window) url)
  )

;; Clicks the button with the specified label
;; (Works with browser and native GUI windows)
(define (click-button label)
    (_click-button (current-window) label)
  )

;; Enters the spcified text into an input field in the current window. e.g.
;; (enter-text "Hello" position: 1) - Enters "Hello" into the first entry field on the window
;; (enter-text "Hello" id: "username") - Enters "Hello" field named "username" [Browser fields only]
;; (Works with browser and native GUI windows)
(define (enter-text text . rest)
  (let ((position 1) (id #f))
    (let cparam ((lst rest)) 
        (cond
          ((null? lst) #t)
          ((eq? (car lst) position:) (set! position (car (cdr lst))))
          ((eq? (car lst) id:) (set! id (car (cdr lst))))
          (else (raise "Unknown parameter to enter-text - need either position: or id:"))))
                        
    (if (not (eq? id #f)) (_enter-text (current-window) text -1 id) 
                        (_enter-text (current-window) text position "")))
  )

;; Gets the entered text from an input field in the current window. e.g.
;; (Works with browser and native GUI windows)
(define (get-entered-text type val)
  (let ((position 1) (id #f))
    (cond
       ((eq? type position:) (set! position val))
       ((eq? type id:) (set! id val))
       (else (raise "Unknown parameter to get-entered-text - need either position: or id:")))
                        
    (if (not (eq? id #f)) (_get-entered-text (current-window) -1 id) 
                        (_get-entered-text (current-window) position "")))
  )

;; Selects the item in a drop down selector . e.g.
;; (select-item text: "Active" position: 1) - selects the 'Active' value from the 1st selection box
;; (select-item item: 2 name: "selectionField") - selects the 2nd option on the select box called 'SelectionField'
;; (Works with browser windows only)
(define (select-item selection-type selection-value type val)
  (let ((item 0) (item-text "") (position 1) (id #f))
    (cond
       ((eq? type position:) (set! position val))
       ((eq? type id:) (set! id val))
       (else (raise "Unknown parameter to select-item - need either position: or id:")))
    (cond
       ((eq? selection-type text:) (set! item-text selection-value))
       ((eq? selection-type item:) (set! item selection-value))
       (else (raise "Unknown parameter to select-item - need either text: or item:")))
    
    (if (= item 0) 
      (if (not (eq? id #f)) (_select-item (current-window) -1 item-text -1 id) 
                            (_select-item (current-window) -1 item-text position ""))
      (if (not (eq? id #f)) (_select-item (current-window) item "" -1 id) 
                            (_select-item (current-window) item "" position "")))
        )
  )

;; Gets the selected item from a select field in the current window. e.g.
;; (Works with browser windows only)
(define (get-selected-item type val)
  (let ((position 1) (id #f))
    (cond
       ((eq? type position:) (set! position val))
       ((eq? type id:) (set! id val))
       (else (raise "Unknown parameter to get-selected-item - need either position: or id:")))
                        
    (if (not (eq? id #f)) (_get-selected-item (current-window) -1 id) 
                        (_get-selected-item (current-window) position "")))
  )

;; Sets the checkbox value
;; (Works with browser windows only)
(define (set-checkbox state type val)
  (let ((position 1) (id #f))
    (cond
       ((eq? type position:) (set! position val))
       ((eq? type id:) (set! id val))
       (else (raise "Unknown parameter to set-checkbox - need either position: or id:")))
    
    (if (not (eq? id #f)) (_set-checkbox (current-window) state -1 id) 
                          (_set-checkbox (current-window) state position ""))
        )
  )

;; Gets the checkbox value
;; (Works with browser windows only)
(define (get-checkbox type val)
  (let ((position 1) (id #f))
    (cond
       ((eq? type position:) (set! position val))
       ((eq? type id:) (set! id val))
       (else (raise "Unknown parameter to get-checkbox - need either position: or id:")))
    
    (if (not (eq? id #f)) (_get-checkbox (current-window) -1 id) 
                          (_get-checkbox (current-window) position ""))
        )
  )

;; Sets the radio button value
;; (Works with browser windows only)
(define (set-radio state type val)
  (let ((position 1))
    (cond
       ((eq? type position:) (set! position val))
       (else (raise "Unknown parameter to set-radio - only position: is supported")))
    (_set-radio (current-window) state position)                           
        )
  )

;; Gets the radio button boolean value
;; (Works with browser windows only)
(define (get-radio type val)
  (let ((position 1))
    (cond
       ((eq? type position:) (set! position val))
       (else (raise "Unknown parameter to get-radio - only position: is supported")))
    (_get-radio (current-window) position)                           
        )
  )

;; Closes the current-window
;; 
(define (window-close)
    (_window-close (current-window))
  )

;; Finds a Window on the desktop with the title text spcified.
;; Returns HWND of the found window
(define (find-window text)
  (let ((hwnd (_find-window text))) 
    (if (= hwnd 0) (raise (string-append "Window not found: " text)) hwnd)
    )
  )

;; Returns a string representing the first string with all superflous whitespace removed
;; similar to trim but will remove runs of spaces, tabs or CR's etc.
(define (compress-whitespace str)
  (let n ((x 0) (txt "") (ws 2))
    (if (= (string-length str) x) txt
      (cond
       ((char-whitespace? (string-ref str x)) (if (= ws 0) (n (+ x 1) txt 1) (n (+ x 1) txt ws)))
       (else (if (= ws 1) 
                 (n (+ x 1) (string-append txt " " (string (string-ref str x))) 0)
                 (n (+ x 1) (string-append txt (string (string-ref str x))) 0)                 
                 ))
       )
     )
    )
  )
       
;; Splits a string (str) into a list using str2 as the split token
;; 
(define (split str str2)
  (let next ((x 0))
    (if (> (string-length str2) (- (string-length str) x)) (list str)
    (let ((m (substring str x (+ x (string-length str2))))) 
    (cond      
     ((string=? m str2) (cons (compress-whitespace (substring str 0 x)) (split (substring str (+ x (string-length str2)) (string-length str)) str2)))
     (else (next (+ x 1))))
    )))
  )

;; Returns the page text as an ordered list
;; suitable for reading tables etc 
;; WARNING: This is very slow for some reason.
(define (get-page-text-list)
  (split (_get-tabulated-text (current-window)) "\n")
  )

;; Returns the text from a table as an ordered list. 
;; Finds the table containing the search text.
;; WARNING: This is quite slow for some reason.
(define (get-table-text-list search-text)
  (split (_get-tabulated-table-text (current-window) search-text) "\n")
  )

;; Returns the page text as one big string 
;; Looks similar to browser view
(define (get-page-text)
  (_get-text (current-window))
  )

;; Returns the page HTML source 
;; 
(define (get-page-html)
  (_get-html (current-window))
  )

;; Search for str2 in str
(define (string-contains str str2)
  (let next ((x 0))
    (if (> (string-length str2) (- (string-length str) x)) #f
    (let ((m (substring str x (+ x (string-length str2))))) 
    (cond      
     ((string-ci=? m str2) #t)
     (else (next (+ x 1))))
    )))
  )

;; Checks for the existence of the text string on the page 
;; 
(define (assert-exists str)
  (let ((page (get-page-text)))
    (if (not (string-contains page str)) (raise (string-append "String " str " not found in page.")))
    )
 )

;; Checks for the non-existence of the text string on the page 
;; 
(define (assert-not-exists str)
  (let ((page (get-page-text)))
    (if (string-contains page str) (raise (string-append "String " str " found in page.")))
    )
 )


;; Given a table-list, this procedure chops into a list of records based on the starting position and the record width 
;;
(define (format-table table starting record-width)
  (let nxt-row ((lst (let nxt ((lst table) (x starting))
                   (cond 
                     ((> x 0) (nxt (cdr lst) (- x 1)))
                     (else lst))))
            (x record-width)
            (row '()))
    (cond 
     ((null? lst) (list row))
     ((= x 0) (cons row (nxt-row lst record-width '())))
     (else (nxt-row (cdr lst) (- x 1) (append row (list (car lst)))))))      
  )

;; Gets a formatted table i.e. list of rows, each row being a list of columns
;; requires the text to search for in a table, the starting offset i.e. how many records to skip 
;; for headings and the width of each record.

(define (get-formatted-table text starting width)
  (format-table (get-table-text-list text) starting width)
  )